home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / err87_13.zip / ERROR87.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-23  |  12KB  |  406 lines
  1. {$n+,s-}
  2. unit error87;
  3.  
  4. interface
  5.  
  6. implementation
  7.  
  8. uses dos,decode87;
  9.  
  10. type
  11.   controlword = set of (Invalidmask, Denormmask, Zerodivmask, Overflowmask,
  12.                         Underflowmask, Precisionmask,
  13.                         CReserved6, IntEnable, Precision0, Precision1, Round0,
  14.                         Round1, Infinity, CReserved13, CReserved14,
  15.                         CReserved15);
  16.  
  17.   statusword = set of (Invalid, Denorm, Zerodiv, Overflow, Underflow, Precision,
  18.                        SReserved6, IntRequest, C0, C1, C2, ST0, ST1, ST2, C3,
  19.                        Busy);
  20.   bitnumbers = 0..15;
  21.   state87  = record
  22.                control  : controlword;
  23.                status   : statusword;
  24.                tags     : word;
  25.                case boolean of
  26.                false: (ip15_0,        { Real mode }
  27.                        ip_opcode,
  28.                        op15_0,
  29.                        op19_16 : word;
  30.                        stack    : array[0..7] of Extended);
  31.                true:  (ip,
  32.                        op : pointer);
  33.              end;
  34.  
  35.   function single_infinite(var s : Single) : Boolean;
  36.   begin
  37.     if (LongInt(s) and $7FFFFFFF) = $7F800000 then
  38.       single_infinite := True
  39.     else
  40.       single_infinite := False;
  41.   end;
  42.  
  43.   function single_nan(var s : Single) : Boolean;
  44.   var
  45.     words    : array[1..2] of Word absolute s;
  46.   begin
  47.     single_nan := False;
  48.     if ((words[2] and $7F80) = $7F80) and (not single_infinite(s)) then
  49.       single_nan := True;
  50.   end;
  51.  
  52.   function double_infinite(var d : Double) : Boolean;
  53.   var
  54.     longs    : array[1..2] of LongInt absolute d;
  55.   begin
  56.     if (longs[2] = $7FFFFFFF) and (longs[1] = 0) then
  57.       double_infinite := True
  58.     else
  59.       double_infinite := False;
  60.   end;
  61.  
  62.   function double_nan(var d : Double) : Boolean;
  63.   var
  64.     words    : array[1..4] of Word absolute d;
  65.   begin
  66.     double_nan := False;
  67.     if (words[4] and $7FF0) = $7FF0 then { not a number, but maybe INF }
  68.       if not double_infinite(d) then
  69.         double_nan := True;
  70.   end;
  71.  
  72.   function extended_infinite(var e : Extended) : Boolean;
  73.   var
  74.     words    : array[1..5] of Word absolute e;
  75.   begin
  76.     if ((words[5] and $7FFF) = $7FFF)
  77.     and (words[4] = $8000)
  78.     and (words[3] = 0)
  79.     and (words[2] = 0)
  80.     and (words[1] = 0) then
  81.       extended_infinite := True
  82.     else
  83.       extended_infinite := False;
  84.   end;
  85.  
  86.   function extended_nan(var e : Extended) : Boolean;
  87.   var
  88.     words    : array[1..5] of Word absolute e;
  89.   begin
  90.     extended_nan := False;
  91.     if ((words[5] and $7FFF) = $7FFF) and
  92.     ((words[4] and $8000) = $8000) then { not a number, but maybe INF }
  93.       if not extended_infinite(e) then
  94.         extended_nan := True;
  95.   end;
  96.  
  97.   function bcd_zero(var b)   : Boolean;
  98.   var
  99.     words    : array[1..5] of Word absolute b;
  100.   begin
  101.     bcd_zero := False;
  102.     if ((words[5] and $7FFF) = 0)
  103.     and (words[4] = 0)
  104.     and (words[3] = 0)
  105.     and (words[2] = 0)
  106.     and (words[1] = 0) then
  107.       bcd_zero := True;
  108.   end;
  109.  
  110. var
  111.   state    : state87;  { In data segment, in case there isn't much stack
  112.                          space }
  113. var
  114.   oldexitproc : Pointer;
  115. {$f+}
  116.   procedure my_exit_proc;
  117.   var
  118.     opcode   : Word;
  119.     last_inst : opcode_info;
  120.     ops_read : operand_set;
  121.     regs_read : operand_set;
  122.     op_address, ip_address : Pointer;
  123.     tos      : 0..7;
  124.     op       : operand_type;
  125.     danger   : Boolean;
  126.  
  127.     function physical(reg : operand_type) : Byte;
  128.       { Return the physical register number of a register }
  129.     begin
  130.       physical := (Ord(reg)+tos) mod 8;
  131.     end;
  132.  
  133.     function tag(reg : operand_type) : Byte;
  134.     begin
  135.       tag := (state.tags shr (2*physical(reg))) and 3;
  136.     end;
  137.  
  138.     function is_a_Nan(op : operand_type) : Boolean;
  139.     begin
  140.       is_a_Nan := False;
  141.       case op of
  142.         arReg0..arReg7 : begin
  143.                            if tag(op) <> 2 then
  144.                              Exit;
  145.                            is_a_Nan := extended_nan(state.stack[ord(op)]);
  146.                          end;
  147.         arSingle : is_a_Nan := single_nan(Single(op_address^));
  148.         arDouble : is_a_Nan := double_nan(Double(op_address^));
  149.         arExtended : is_a_Nan := extended_nan(Extended(op_address^));
  150.       end;
  151.       { others can't be NaNs }
  152.     end;
  153.  
  154.     function is_a_zero(op : operand_type) : Boolean;
  155.     begin
  156.       is_a_zero := False;
  157.       case op of
  158.         arReg0..arReg7 : begin
  159.                            if tag(op) = 1 then
  160.                              is_a_zero := True;
  161.                          end;
  162.         arSingle :
  163.           is_a_zero := (Single(op_address^) = 0.0);
  164.         arDouble :
  165.           is_a_zero := (Double(op_address^) = 0.0);
  166.         arExtended :
  167.           is_a_zero := (Extended(op_address^) = 0.0);
  168.         arWord :
  169.           is_a_zero := (Word(op_address^) = 0);
  170.         arLongint :
  171.           is_a_zero := (LongInt(op_address^) = 0);
  172.         arComp :
  173.           is_a_zero := (Comp(op_address^) = 0);
  174.         arBCD :
  175.           is_a_zero := bcd_zero(op_address^);
  176.       end;
  177.     end;
  178.  
  179.   function PtrToLong(p:pointer):longint;
  180.   begin
  181.     PtrToLong := longint(seg(p^)) shl 4 + ofs(p^);
  182.   end;
  183.  
  184.   function PtrDiff(p1,p2:pointer):longint;
  185.   begin
  186.     PtrDiff := abs(PtrToLong(p1)-PtrToLong(p2));
  187.   end;
  188.  
  189.   procedure adjust_for_prefix;
  190.   var
  191.     temp : longint;
  192.   begin
  193.     temp := PtrToLong(ip_address)-longint(prefixseg)*$10-$100;
  194.     { this is the linear address relative to the start of the program }
  195.     ip_address := ptr((temp and $FFFF0000) shl 12, temp and $FFFF);
  196.       { ip_address will have smallest possible segment number }
  197.       { User must manually work out true segment value }
  198.   end;
  199.  
  200.   procedure Find_ip;
  201.   var
  202.     i : integer;
  203.   begin
  204.     ip_address := Ptr(seg(ErrorAddr^)+PrefixSeg+$10,ofs(ErrorAddr^)-5);
  205.     { Start looking 5 bytes before ErrorAddr }
  206.     for i:=1 to 5 do
  207.     begin
  208.       if byte(ip_address^) = $CD then
  209.         exit;
  210.       ip_address := Ptr(seg(ip_address^),ofs(ip_address^)+1);
  211.     end;
  212.     ip_address := nil;
  213.   end;
  214.  
  215.   procedure rangecheck(lower,upper:extended);
  216.   var
  217.     reg : operand_type;
  218.   begin
  219.     if (last_inst.inst = iFISTP) and (tag(arReg0) = 3) then
  220.       reg := arReg7  { This doesn't really belong here, but
  221.                        a pop happens in trunc() because it temporarily
  222.                        masks exceptions. }
  223.     else
  224.       reg := arReg0;
  225.     danger :=   (state.stack[ord(reg)] < lower)
  226.              or (state.stack[ord(reg)] > upper);
  227.   end;
  228.  
  229.   begin                           {my_exit_proc}
  230.     ExitProc := oldexitproc;
  231.     if (ErrorAddr = nil) or (ExitCode <> 207) then
  232.       Exit;
  233.  
  234.     inline($cd/$39/$36/state/$9b);
  235.     if test8087 > 0 then          { Is this a real '87? }
  236.     begin
  237.       {$ifndef dpmi}
  238.       opcode := state.ip_opcode and $07FF+$d800;
  239.       op_address := Ptr(state.op19_16 and $F000, state.op15_0);
  240.       {$else}
  241.       opcode := swap(word(state.ip^));
  242.       op_address := state.op;
  243.       {$endif}
  244.  
  245.       {$ifdef ver70}
  246.       ip_address := ErrorAddr;
  247.       {$else}
  248.       ip_address := Ptr(state.ip_opcode and $F000, state.ip15_0);
  249.  
  250.       adjust_for_prefix;  { Make ip_address on same scale as ErrorAddr }
  251.  
  252.       if ptrdiff(ErrorAddr,ip_address) > 10 then
  253.         ErrorAddr := ip_address;
  254.       {$endif}
  255.     end
  256.     else
  257.     begin    { Handle the emulator }
  258.       find_ip;
  259.       if ip_address = nil then
  260.       begin
  261.         writeln('Error probably occurred in library routine.  Error87 can''t help.');
  262.         exit;
  263.       end;
  264.  
  265.       { Now ip_address points to $CD byte before instruction }
  266.       ip_address := Ptr(seg(ip_address^),ofs(ip_address^)+1);
  267.       opcode := swap(word(ip_address^)) + $a400;
  268.       op_address := Ptr(dseg, Memw[seg(ip_address^):ofs(ip_address^)+2]);
  269.                    { we don't know the segment, but we can guess }
  270.     end;
  271.  
  272.     decode_opcode(opcode, last_inst);
  273.     operands_read(last_inst, ops_read);
  274.     regs_read := ops_read*[arReg0..arReg7];
  275.  
  276.     tos := (Word(state.status)